home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
GAUGE.ARJ
/
GAUGE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-01-28
|
17KB
|
671 lines
{$N+}
{$R GAUGE}
program Gauge;
uses
WinTypes, WinProcs, WinDOS, Strings;
const
ids_FSpace = 101; (* Free Disk Space Static Control *)
ids_TSpace = 102; (* Total Disk Space Static Control *)
ids_FMem = 103; (* Free Memory Static Control *)
ids_FRes = 104; (* Free System Resources Static Control *)
ids_Date = 105; (* Date Static Control *)
ids_Time = 106; (* Time Static Control *)
ids_DriveText = 120; (* Text rectangle for Drive Space *)
idc_Drives = 107; (* Drive Selection Combo Box *)
idr_DSpace = 108; (* Disk Space Radio Button *)
idr_Memory = 109; (* Memory Radio Button *)
idr_SysRes = 110; (* System Resources Radio Button *)
idr_Time = 111; (* Time Radio Button *)
idr_Date = 112; (* Date Radio Button *)
idb_OK = 113; (* OK Push Button *)
ida_OK = 100;
idm_About = 200;
id_Timer = 1;
tDiskRect : TRect = (left : 125; top : 15; right : 375; bottom : 35);
avMem : PChar = Nil;
avResource : PChar = Nil;
theTime : PChar = Nil;
theDate : PChar = Nil;
type
DriveStr = array[0..2] of Char;
DriveRec = Record
dLetter : DriveStr;
dTotal : LongInt;
end;
var
avDiskRect : TRect;
curChoice,
lastDrive,
curDrive : Integer;
avDrives : array[0..23] of DriveRec;
sDate : array[0..1] of Char;
sTime : array[0..1] of Char;
sAMPM : array[0..1, 0..4] of Char;
psAMPM : array[0..1] of String;
iDate,
iTime : Integer;
dChoice : Integer;
(* ------------- Undocumented Windows function ---------------- *)
function GetHeapSpaces(hModule : THandle) : LongInt; far;
external 'KERNEL' index 138;
(* ------------------------------------------------------------- *)
function AboutDlgProc(hDlg : hWnd; message, wParam : Word;
lParam : LongInt) : Bool; Export;
begin
AboutDlgProc := True;
case message of
wm_InitDialog :
begin
Exit;
end;
wm_Command :
begin
case wParam of
ida_OK :
begin
EndDialog(hDlg, 0);
Exit;
end;
end;
end;
end;
AboutDlgProc := False;
end;
function min(x, y : Word) : Word;
begin
if x > y then
min := y
else
min := x;
end;
function OneDriveInfo(drive : Integer; var total : LongInt) : Boolean;
var
dType : Word;
begin
OneDriveInfo := False;
total := 0;
dType := GetDriveType(drive - 1);
if (dType = drive_Fixed) or (dType = drive_Removable) then begin
OneDriveInfo := True;
if dType <> drive_Remote then
total := DiskSize(drive) div 1024 div 1024;
end;
end;
function GetDriveInfo : Integer;
var
i, j : Integer;
Total : LongInt;
isOK : Boolean;
begin
i := 3;
j := -1;
isOK := True;
while isOK do begin
isOK := OneDriveInfo(i, Total);
if isOK then begin
if (Total <> 0) then begin
Inc(j);
with avDrives[j] do begin
dTotal := Total;
dLetter[0] := Chr(i + 64);
dLetter[1] := ':';
end;
Inc(i);
end
else
isOK := False;
end;
end;
GetDriveInfo := j;
end;
function GetFreeMemory : String;
var
dwFreeMem : LongInt;
curMem,
rMem : Real;
temp : String;
begin
dwFreeMem := GetFreeSpace(0);
curMem := dwFreeMem;
rMem := curMem / 1024.0 / 1024.0;
Str(rMem:5:2, temp);
GetFreeMemory := Concat(temp, ' Mb');
end;
procedure heapInfo(module : PChar; var pfree, ptotal, ppercent : Word);
var
info : LongInt;
begin
info := GetHeapSpaces(GetModuleHandle(module));
pfree := LoWord(info);
ptotal := Hiword(info);
info := Word((LongInt(pfree) * 100) div ptotal);
ppercent := info;
end;
function GetFreeResources : LongInt;
var
userFree,
userTotal,
userPercent,
gdiFree,
gdiTotal,
gdiPercent : Word;
begin
heapInfo('USER', userFree, userTotal, userPercent);
heapInfo('GDI', gdiFree, gdiTotal, gdiPercent);
(*GetFreeResources := min(userPercent, gdiPercent);*)
GetFreeResources := MakeLong(userPercent, gdiPercent);
end;
procedure SetInternational;
const
cName = 'intl';
begin
iDate := GetProfileInt(cName, 'iDate', 0);
iTime := GetProfileInt(cName, 'iTime', 0);
GetProfileString(cName, 'sDate', '/', sDate, 2);
GetProfileString(cName, 'sTime', ':', sTime, 2);
GetProfileString(cName, 's1159', 'AM', sAMPM[0], 5);
GetProfileString(cName, 's2359', 'PM', sAMPM[1], 5);
psAMPM[0] := StrPas(sAMPM[0]);
psAMPM[1] := StrPas(sAMPM[1]);
end;
procedure ModifyText(var hh : String);
begin
if hh[1] = ' ' then
hh[1] := '0';
end;
function GetCurTime : String;
var
hr,
min,
sec,
hsec : Word;
temp,
shour,
smin : String;
begin
GetTime(hr, min, sec, hsec);
Str(hr:2, shour);
Str(min:2, smin);
ModifyText(shour);
ModifyText(smin);
if iTime = 1 then
temp := Concat(shour, sTime[0], smin)
else begin
if (hr mod 12) <> 0 then
Str(hr mod 12:2, shour)
else
shour := '12';
temp:= Concat(shour, sTime[0], smin, ' ', psAMPM[hr div 12]);
end;
GetCurTime := temp;
end;
function GetCurDate : String;
var
yr,
mo,
day,
dweek : Word;
temp,
smo,
syr,
sday : String;
begin
GetDate(yr, mo, day, dweek);
Str(yr mod 100:2, syr);
Str(mo:2, smo);
Str(day:2, sday);
ModifyText(syr);
ModifyText(smo);
ModifyText(sday);
if iDate = 1 then
temp := Concat(sday, sDate[0], smo, sDate[0], syr)
else if iDate = 2 then
temp := Concat(syr, sDate[0], smo, sDate[0], sday)
else
temp := Concat(smo, sDate[0], sday, sDate[0], syr);
GetCurDate := temp;
end;
procedure SetupDlg(Window : HWnd);
var
curDir : PChar;
begin
GetMem(curDir, fsDirectory);
GetCurDir(curDir, 0);
curDrive := Ord(curDir[0]) - 67;
FreeMem(curDir, fsDirectory);
SetInternational;
(* First, determine the available drives, skipping A: & B: *)
lastDrive := GetDriveInfo;
curChoice := idr_DSpace;
CheckRadioButton(Window, idr_DSpace, idr_Date, curChoice);
end;
procedure GetAvail(theDrive : Integer; total : LongInt;
var avail : LongInt; var ratio : Single);
begin
avail := DiskFree(theDrive + 3) div 1024 div 1024;
ratio := Single(avail) / Single(total);
end;
procedure WndPaint(Window : HWnd; aDC : HDC);
const
dAdded : Boolean = False;
var
noDC : Boolean;
ps : TPaintStruct;
buffer : array[0..20] of Char;
temp : Single;
tInt : LongInt;
oldBrush,
redBrush : HBrush;
i : Integer;
theErr : LongInt;
avSpace : LongInt;
dRatio : Single;
oldColor : LongInt;
begin
if aDC = 0 then
begin
aDC := GetDC(Window);
noDC := True;
end
else
noDC := False;
GetAvail(curDrive, avDrives[curDrive].dTotal, avSpace, dRatio);
with tDiskRect do
Rectangle(aDC, left, top, right, bottom);
with avDiskRect do begin
left := tDiskRect.left;
top := tDiskRect.top;
bottom := tDiskRect.bottom;
tInt := tDiskRect.right - tDiskRect.left;
temp := Single(tInt) * dRatio;
right := LongInt(temp) + left;
end;
redBrush := CreateSolidBrush(RGB(255, 0, 0));
oldBrush := SelectObject(aDC, redBrush);
with avDiskRect do
Rectangle(aDC, left, top, right, bottom);
SelectObject(aDC, oldBrush);
DeleteObject(redBrush);
wvsprintf(buffer, '%lu Mb', avSpace);
SetDlgItemText(Window, ids_FSpace, buffer);
wvsprintf(buffer, '%lu Mb', avDrives[curDrive].dTotal);
SetDlgItemText(Window, ids_TSpace, buffer);
if avMem <> Nil then
FreeMem(avMem, 10);
GetMem(avMem, 10);
StrPCopy(avMem, GetFreeMemory); (* get memory *)
theErr := GetFreeResources; (* LoWord = user, HiWord = GDI *)
if avResource <> Nil then
FreeMem(avResource, 25);
GetMem(avResource, 25);
wvsprintf(avResource, '%2u%% User %2u%% GDI', theErr);
if theTime <> Nil then
FreeMem(theTime, 15);
GetMem(theTime, 15);
StrPCopy(theTime, GetCurTime);
if theDate <> Nil then
FreeMem(theDate, 15);
GetMem(theDate, 15);
StrPCopy(theDate, GetCurDate);
SetDlgItemText(Window, ids_FMem, avMem);
SetDlgItemText(Window, ids_FRes, avResource);
SetDlgItemText(Window, ids_Date, theDate);
SetDlgItemText(Window, ids_Time, theTime);
CheckRadioButton(Window, idr_DSpace, idr_Date, curChoice);
if (not dAdded) then begin
for i := 0 to lastDrive do
theErr := SendDlgItemMessage(Window, idc_Drives, lb_AddString,
0, LongInt(@avDrives[i].dLetter));
dAdded := True;
end;
theErr := SendDlgItemMessage(Window, idc_Drives, lb_SetCurSel,
curDrive, 0);
if (noDC) then
ReleaseDC(Window, aDC);
end;
procedure DrawDrive(Window : HWnd; aDC : HDC; Rect : TRect);
var
aRect : TRect;
oldBrush,
aBrush : HBrush;
tInt : LongInt;
temp : Single;
oldMode : Integer;
oldAlign : Word;
avSpace : LongInt;
dRatio : Single;
begin
GetAvail(curDrive, avDrives[curDrive].dTotal, avSpace, dRatio);
with aRect do begin
left := Rect.left;
right := Rect.right;
top := Rect.top;
tInt := Rect.bottom;
temp := Single(tInt) * dRatio;
bottom := LongInt(temp);
end;
aBrush := CreateSolidBrush(RGB(255, 0, 0));
oldBrush := SelectObject(aDC, aBrush);
with aRect do
Rectangle(aDC, left, top, right, bottom);
SelectObject(aDC, oldBrush);
DeleteObject(aBrush);
oldMode := SetBkMode(aDC, Transparent);
TextOut(aDC, Rect.left + 10, Rect.top + 10, avDrives[curDrive].dLetter,
strlen(avDrives[curDrive].dLetter));
SetBkMode(aDC, oldMode);
end;
procedure DrawMemory(Window : HWnd; aDC : HDC; Rect : TRect);
var
oldMode : Integer;
begin
if avMem <> Nil then
FreeMem(avMem, 10);
GetMem(avMem, 10);
StrPCopy(avMem, GetFreeMemory); (* get memory *)
oldMode := SetBkMode(aDC, Transparent);
DrawText(aDC, avMem, strlen(avMem), Rect, dt_WordBreak);
SetBkMode(aDC, oldMode);
end;
procedure DrawSysRes(Window : HWnd; aDC : HDC; Rect : TRect);
var
oldMode : Integer;
lRes : LongInt;
tWord : Word;
begin
lRes := GetFreeResources; (* get free resources *)
tWord := min(LoWord(lRes), HiWord(lRes));
if avResource <> Nil then
FreeMem(avResource, 25);
GetMem(avResource, 25);
wvsprintf(avResource, '%2u%% Avail', tWord);
oldMode := SetBkMode(aDC, Transparent);
DrawText(aDC, avResource, strlen(avResource), Rect, dt_WordBreak);
SetBkMode(aDC, oldMode);
end;
procedure DrawTime(Window : HWnd; aDC : HDC; Rect : TRect);
var
oldMode : Integer;
begin
if theTime <> Nil then
FreeMem(theTime, 15);
GetMem(theTime, 15);
StrPCopy(theTime, GetCurTime);
oldMode := SetBkMode(aDC, Transparent);
DrawText(aDC, theTime, strlen(theTime), Rect, dt_WordBreak);
SetBkMode(aDC, oldMode);
end;
procedure DrawDate(Window : HWnd; aDC : HDC; Rect : TRect);
var
oldMode : Integer;
begin
if theDate <> Nil then
FreeMem(theDate, 15);
GetMem(theDate, 15);
StrPCopy(theDate, GetCurDate);
oldMode := SetBkMode(aDC, Transparent);
DrawText(aDC, theDate, strlen(theDate), Rect, dt_WordBreak);
SetBkMode(aDC, oldMode);
end;
procedure IconPaint(Window : HWnd; aDC : HDC);
var
theRect : TRect;
oldBrush,
aBrush : HBrush;
begin
GetClientRect(Window, theRect);
aBrush := CreateSolidBrush(RGB(255, 255, 255));
oldBrush := SelectObject(aDC, aBrush);
with theRect do
Rectangle(aDC, left, top, right, bottom);
SelectObject(aDC, oldBrush);
DeleteObject(aBrush);
case curChoice of
idr_DSpace : DrawDrive(Window, aDC, theRect);
idr_Memory : DrawMemory(Window, aDC, theRect);
idr_SysRes : DrawSysRes(Window, aDC, theRect);
idr_Time : DrawTime(Window, aDC, theRect);
idr_Date : DrawDate(Window, aDC, theRect);
end;
end;
function WndProc(Window : hWnd; Message, wParam : word;
lParam : Longint) : Longint; export;
const
hInst : THandle = 0;
lpfnAboutDlgProc : TFarProc = Nil;
ctlBrush : HBrush = 0;
var
aDC : HDC;
ps : TPaintStruct;
hControl : HWnd;
begin
WndProc := 0;
case Message of
wm_Create :
begin
hInst := GetWindowWord(Window, gww_hInstance);
lpfnAboutDlgProc := MakeProcInstance(@AboutDlgProc, hInst);
ctlBrush := CreateSolidBrush(RGB(255, 0, 0));
SetUpDlg(Window);
Exit;
end;
wm_CtlColor :
begin
if (GetDlgCtrlId(LoWord(lParam)) = ids_FSpace) then
if (HiWord(lParam) = ctlcolor_Static) then begin
SetBkColor(wParam, RGB(255, 0, 0));
SetTextColor(wParam, RGB(255, 255, 255));
WndProc := LongInt(ctlBrush);
Exit;
end
end;
wm_SysCommand :
begin
if wParam = idm_About then begin
DialogBox(hInst, 'AboutBox', Window, lpfnAboutDlgProc);
Exit;
end;
end;
wm_Timer :
begin
if (isIconic(Window)) then
InvalidateRect(Window, Nil, True)
else
WndPaint(Window, 0);
Exit;
end;
wm_Paint :
begin
aDC := BeginPaint(Window, ps);
if (isIconic(Window)) then
IconPaint(Window, aDC)
else
WndPaint(Window, aDC);
EndPaint(Window, ps);
Exit;
end;
wm_Command :
begin
case wParam of
idr_DSpace,
idr_Memory,
idr_SysRes,
idr_Time,
idr_Date :
begin
curChoice := wParam;
CheckRadioButton(Window, idr_DSpace, idr_Date, wParam);
Exit;
end;
idc_Drives :
begin
hControl := GetDlgItem(Window, idc_Drives);
curDrive := SendMessage(hControl, lb_GetCurSel, 0, 0);
WndPaint(Window, 0);
Exit;
end;
idb_OK :
begin
CloseWindow(Window);
Exit;
end;
end; (* case *)
end;
wm_Destroy:
begin
DeleteObject(ctlBrush);
KillTimer(Window, id_Timer);
PostQuitMessage(0);
Exit;
end;
end; { case }
WndProc := DefWindowProc(Window, Message, wParam, lParam);
end;
procedure WinMain;
const
szAppName = 'Gauge';
WClass : TWndClass = (
Style : cs_HRedraw or cs_VRedraw;
lpfnWndProc : @WndProc;
cbClsExtra : 0;
cbWndExtra : DlgWindowExtra;
hInstance : 0;
hIcon : 0;
hCursor : 0;
hbrBackground : 0;
lpszMenuName : nil;
lpszClassName : szAppName);
var
Window : HWnd;
msg : TMsg;
aMenu : HMenu;
begin
if (hPrevInst = 0) then begin
WClass.hInstance := hInstance;
WClass.hCursor := LoadCursor(0, idc_Arrow);
(*WClass.hbrBackground := GetStockObject(White_Brush);*)
WClass.hbrBackground := Color_Window + 1;
if not RegisterClass(WClass) then
Halt(255);
end;
Window := CreateDialog(hInstance, szAppName, 0, Nil);
aMenu := GetSystemMenu(Window, False);
AppendMenu(aMenu, mf_Separator, 0, Nil);
AppendMenu(aMenu, mf_String, idm_About, 'About...');
EnableMenuItem(aMenu, 2, mf_byPosition or mf_Grayed);
EnableMenuItem(aMenu, 4, mf_byPosition or mf_Grayed);
if (SetTimer(Window, id_Timer, 10000, Nil) = 0) then begin
MessageBox(Window, 'Too many clocks or timers!',
szAppName, mb_IconExclamation or mb_Ok);
end;
ShowWindow(Window, CmdShow);
while GetMessage(msg, 0, 0, 0) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
Halt(msg.wParam);
end;
begin
WinMain;
end.